home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Oberon / source / OC / OCE.mod < prev    next >
Text File  |  1995-07-02  |  51KB  |  1,566 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCE.mod $
  4.   Description: Code selection for expressions
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.22 $
  8.       $Author: fjc $
  9.         $Date: 1995/07/02 16:52:04 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1995, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. *************************************************************************)
  19.  
  20. <* STANDARD- *> <* MAIN- *> <*$ LongVars+ *>
  21.  
  22. MODULE OCE;
  23.  
  24. IMPORT SYS := SYSTEM, OCM, OCS, OCT, OCC, OCI;
  25.  
  26.  
  27. (* --- Local declarations --------------------------------------------- *)
  28.  
  29. CONST
  30.  
  31.   (* Symbols *)
  32.  
  33.   null = OCS.null; times = OCS.times; slash = OCS.slash; div   = OCS.div;
  34.   mod  = OCS.mod;  and   = OCS.and;   plus  = OCS.plus;  minus = OCS.minus;
  35.   or   = OCS.or;   eql   = OCS.eql;   neq   = OCS.neq;   lss   = OCS.lss;
  36.   leq  = OCS.leq;  gtr   = OCS.gtr;   geq   = OCS.geq;   not   = OCS.not;
  37.  
  38.   (* object modes *)
  39.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  40.   RegI = OCM.RegI; RegX = OCM.RegX; Lab = OCM.Lab; LabI = OCM.LabI;
  41.   Con = OCM.Con; Push = OCM.Push; Pop = OCM.Pop; Coc = OCM.Coc;
  42.   Reg = OCM.Reg; Fld = OCM.Fld; Typ = OCM.Typ; Abs = OCM.Abs;
  43.   XProc = OCM.XProc; RList = OCM.RList;
  44.  
  45.   (* System flags *)
  46.  
  47.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  48.   BCPLFlag = OCM.BCPLFlag; AsmFlag = OCM.AsmFlag;
  49.  
  50.   (* structure forms *)
  51.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  52.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  53.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  54.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  55.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  56.   Record = OCT.Record; PtrTyp = OCT.PtrTyp; AdrTyp = OCT.AdrTyp;
  57.   BPtrTyp = OCT.BPtrTyp; BSet = OCT.BSet; WSet = OCT.WSet;
  58.   Word = OCT.Word; Longword = OCT.Longword; TagTyp = OCT.TagTyp;
  59.  
  60.   intSet   = {SInt, Int, LInt};
  61.   realSet  = {Real, LReal};
  62.   setSet   = {BSet, WSet, Set};
  63.   ptrSet   = {Pointer, PtrTyp, AdrTyp, BPtrTyp};
  64.   uptrSet  = {AdrTyp, BPtrTyp};
  65.   allSet   = {0 .. 31};
  66.   adrSet   = {LInt, Pointer, PtrTyp, AdrTyp, Longword};
  67.  
  68.   (* CPU Registers *)
  69.  
  70.   D0 = 0; D1 = 1; D7 = 7; A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  71.   A6 = 14; A7 = 15; BP = A4; FP = A5; SP = A7;
  72.   DataRegs = {D0 .. D7};
  73.   AdrRegs = {A0 .. A7};
  74.  
  75.   (* Data sizes *)
  76.  
  77.   B = 1; W = 2; L = 4;
  78.  
  79.   (* mathffp.library function offsets *)
  80.  
  81.   SPFix = -30; SPFlt = -36; SPCmp = -42; SPTst = -48; SPAbs = -54;
  82.   SPNeg = -60; SPAdd = -66; SPSub = -72; SPMul = -78; SPDiv = -84;
  83.   SPFloor = -90; SPCeil = -96;
  84.  
  85. VAR
  86.   log : LONGINT; (* side effect of mant () *)
  87.  
  88. (* --- Procedure declarations ------------------------------------------- *)
  89.  
  90. PROCEDURE^ Op *
  91.   (op : INTEGER; VAR lhs, rhs : OCT.Item; freeRegs : BOOLEAN);
  92.  
  93. (*------------------------------------*)
  94. PROCEDURE mant (x : LONGINT) : LONGINT; (* x DIV 2 ^ log *)
  95.  
  96. BEGIN (* mant *)
  97.   log := 0;
  98.   IF x > 0 THEN WHILE ~ODD (x) DO x := x DIV 2; INC (log) END END;
  99.   RETURN x
  100. END mant;
  101.  
  102. (*------------------------------------*)
  103. PROCEDURE MultiplyInts (
  104.   VAR lhs, rhs : OCT.Item; size : LONGINT; freeRegs : BOOLEAN);
  105.  
  106.   VAR R : OCC.RegState; x : OCT.Item;
  107.  
  108. BEGIN (* MultiplyInts *)
  109.   IF (lhs.mode = Con) & (mant (lhs.a0) = 1) THEN
  110.     IF log = 1 THEN
  111.       OCI.Load (rhs); OCC.PutF5 (OCC.ADD, size, rhs, rhs)
  112.     ELSIF log # 0 THEN
  113.       lhs.a0 := log; lhs.typ := OCT.sinttyp;
  114.       IF log > 8 THEN OCI.Load (lhs) END;
  115.       OCI.Load (rhs); OCC.Shift (OCC.ASL, size, lhs, rhs);
  116.       IF log > 8 THEN OCC.FreeReg (lhs) END;
  117.     END;
  118.     lhs := rhs; rhs.mode := Undef
  119.   ELSIF (rhs.mode = Con) & (mant (rhs.a0) = 1) THEN
  120.     IF log = 1 THEN
  121.       OCI.Load (lhs); OCC.PutF5 (OCC.ADD, size, lhs, lhs)
  122.     ELSIF log # 0 THEN
  123.       rhs.a0 := log; rhs.typ := OCT.sinttyp;
  124.       IF log > 8 THEN OCI.Load (rhs) END;
  125.       OCI.Load (lhs); OCC.Shift (OCC.ASL, size, rhs, lhs)
  126.     END
  127.   ELSE
  128.     IF size = L THEN
  129.       OCC.LoadRegParams2 (R, lhs, rhs);
  130.       OCC.CallKernel (OCC.kMul32);
  131.       OCC.RestoreRegisters (R, lhs);
  132.     ELSE
  133.       IF lhs.mode = Con THEN x := lhs; lhs := rhs; rhs := x END;
  134.       OCI.Load (lhs);
  135.       IF size = B THEN
  136.         OCI.EXT (W, lhs.a0);
  137.         IF rhs.mode # Con THEN OCI.Load (rhs); OCI.EXT (W, rhs.a0) END;
  138.       END;
  139.       OCC.PutF2 (OCC.MULS, rhs, lhs.a0);
  140.       IF OCS.pragma [OCS.ovflChk] THEN
  141.         OCC.GetDReg (x, NIL); OCC.Move (size, lhs, x);
  142.         IF size = B THEN OCI.EXT (W, x.a0) END; OCI.EXT (L, x.a0);
  143.         OCI.CMP (L, lhs, x);
  144.         OCC.TrapCC (OCC.RangeCheck, OCC.NE)
  145.       END
  146.     END
  147.   END;
  148.   IF freeRegs THEN OCI.Unload (rhs) END
  149. END MultiplyInts;
  150.  
  151. (*------------------------------------*)
  152. PROCEDURE DivideInts (
  153.   VAR lhs, rhs : OCT.Item; size : LONGINT; freeRegs : BOOLEAN);
  154.  
  155.   VAR R : OCC.RegState;
  156.  
  157. BEGIN (* DivideInts *)
  158.   IF (rhs.mode = Con) & (mant (rhs.a0) = 1) THEN
  159.     rhs.a0 := log; rhs.typ := OCT.sinttyp;
  160.     IF log > 8 THEN OCI.Load (rhs) END;
  161.     OCI.Load (lhs);
  162.     OCC.Shift (OCC.ASR, size, rhs, lhs);
  163.   ELSE
  164.     IF size = OCM.LIntSize THEN
  165.       OCC.LoadRegParams2 (R, lhs, rhs);
  166.       OCC.CallKernel (OCC.kDiv32);
  167.       OCC.RestoreRegisters (R, lhs);
  168.     ELSE
  169.       OCI.Load (lhs);
  170.       IF lhs.typ^.form = OCT.SInt THEN OCI.EXT (W, lhs.a0) END;
  171.       OCI.EXT (L, lhs.a0);
  172.       IF rhs.typ^.form = OCT.SInt THEN
  173.         OCI.Load (rhs); OCI.EXT (W, rhs.a0)
  174.       END;
  175.       OCC.PutF2 (OCC.DIVS, rhs, lhs.a0);
  176.       (*IF OCS.pragma [OCS.ovflChk] THEN OCC.OutOp0 (TRAPV) END;*)
  177.     END
  178.   END;
  179.   IF freeRegs THEN OCI.Unload (rhs) END;
  180. END DivideInts;
  181.  
  182. (*------------------------------------*)
  183. PROCEDURE ModulusInts (
  184.   VAR lhs, rhs : OCT.Item; size : LONGINT; freeRegs : BOOLEAN);
  185.  
  186.   VAR R : OCC.RegState;
  187.  
  188. BEGIN (* ModulusInts *)
  189.   IF (rhs.mode = Con) & (mant (rhs.a0) = 1) THEN
  190.     rhs.a0 := ASH (1, log) - 1; OCI.Load (lhs);
  191.     OCC.PutF6 (OCC.ANDI, size, rhs, lhs)
  192.   ELSE
  193.     IF size = OCM.LIntSize THEN
  194.       OCC.LoadRegParams2 (R, lhs, rhs);
  195.       OCC.CallKernel (OCC.kDiv32);
  196.       OCC.PutWord (0C141H);                                 (* EXG D0,D1 *)
  197.       OCC.RestoreRegisters (R, lhs)
  198.     ELSE
  199.       OCI.Load (lhs);
  200.       IF lhs.typ^.form = OCT.SInt THEN OCI.EXT (W, lhs.a0) END;
  201.       OCI.EXT (L, lhs.a0);
  202.       IF rhs.typ^.form = OCT.SInt THEN
  203.         OCI.Load (rhs); OCI.EXT (L, rhs.a0)
  204.       END;
  205.       OCC.PutF2 (OCC.DIVS, rhs, lhs.a0);
  206.       OCC.PutWord (OCC.SWAP + lhs.a0)
  207.     END
  208.   END;
  209.   IF freeRegs THEN OCI.Unload (rhs) END
  210. END ModulusInts;
  211.  
  212. (*------------------------------------*)
  213. PROCEDURE ConvertInts * (VAR x : OCT.Item; typ : OCT.Struct);
  214.  
  215. BEGIN (* ConvertInts *)
  216.   IF x.mode # Con THEN
  217.     OCI.Load (x);
  218.     IF (typ.form = LInt) & (x.typ.form = SInt) THEN OCI.EXT (W, x.a0) END;
  219.     OCI.EXT (typ.size, x.a0)
  220.   END;
  221.   x.typ := typ
  222. END ConvertInts;
  223.  
  224.  
  225. (*------------------------------------*)
  226. PROCEDURE RealMath (op : INTEGER; VAR lhs, rhs : OCT.Item);
  227.  
  228.   VAR proc : INTEGER; R : OCC.RegState;
  229.  
  230. BEGIN (* RealMath *)
  231.   OCC.LoadRegParams2 (R, lhs, rhs);
  232.   CASE op OF
  233.     times : proc := OCC.kSPMul | slash : proc := OCC.kSPDiv |
  234.     plus  : proc := OCC.kSPAdd | minus : proc := OCC.kSPSub
  235.   ELSE
  236.     OCS.Mark (1009); OCS.Mark (op)
  237.   END;
  238.   OCC.CallKernel (proc); OCC.RestoreRegisters (R, lhs)
  239. END RealMath;
  240.  
  241. (*------------------------------------*)
  242. PROCEDURE CmpReals (VAR lhs, rhs : OCT.Item);
  243.  
  244.   VAR R : OCC.RegState; proc : INTEGER;
  245.  
  246. BEGIN (* CmpReals *)
  247.   IF (rhs.mode = Con) & (rhs.a0 = 0) THEN
  248.     OCC.LoadRegParams1 (R, lhs); proc := OCC.kSPTst
  249.   ELSE
  250.     OCC.LoadRegParams2 (R, lhs, rhs); proc := OCC.kSPCmp
  251.   END;
  252.   OCC.CallKernel (proc); OCC.RestoreRegisters (R, lhs)
  253. END CmpReals;
  254.  
  255. (*------------------------------------*)
  256. PROCEDURE ConvertReals (VAR x : OCT.Item; typ : OCT.Struct);
  257.  
  258.   VAR r0 : OCT.Item; R : OCC.RegState; f : INTEGER; real : REAL;
  259.  
  260. BEGIN (* ConvertReals *)
  261.   f := x.typ.form;
  262.   IF f IN intSet THEN
  263.     IF x.mode = Con THEN
  264.       real := x.a0; x.a0 := SYS.VAL (LONGINT, real)
  265.     ELSE
  266.       r0.mode := Reg; r0.a0 := D0;
  267.       OCC.LoadRegParams1 (R, x);
  268.       IF f = SInt THEN OCI.EXT (W, r0.a0); f := Int END;
  269.       IF f = Int THEN OCI.EXT (L, r0.a0) END;
  270.       OCC.CallKernel (OCC.kSPFlt);
  271.       OCC.RestoreRegisters (R, x)
  272.     END
  273.   END;
  274.   x.typ := typ
  275. END ConvertReals;
  276.  
  277. (*------------------------------------*)
  278. PROCEDURE NegReal (VAR x : OCT.Item);
  279.  
  280.   VAR R : OCC.RegState;
  281.  
  282. BEGIN (* NegReal *)
  283.   OCC.LoadRegParams1 (R, x);
  284.   OCC.CallKernel (OCC.kSPNeg);
  285.   OCC.RestoreRegisters (R, x)
  286. END NegReal;
  287.  
  288. (*------------------------------------*)
  289. PROCEDURE loadB (VAR x : OCT.Item); (* Coc-Mode *)
  290.  
  291.   VAR op, L0 : LONGINT;
  292.  
  293. BEGIN (* loadB *)
  294.   IF ((x.a1 = 0) & (x.a2 = 0)) OR (x.a0 IN {OCC.T, OCC.F}) THEN
  295.     op := OCC.Scc + (x.a0 * 100H);
  296.     OCC.GetDReg (x, NIL); OCC.PutF3 (op, x)                  (*    Scc Dn *)
  297.   ELSE
  298.     op := OCC.Bcc + (OCC.invertedCC (x.a0) * 100H);
  299.     OCC.PutWord (op); OCC.PutWord (x.a2);                    (*    Bcc 1$ *)
  300.     L0 := OCC.pc - 2; OCC.FixLink (x.a1);
  301.     OCC.GetDReg (x, NIL); OCC.PutF3 (OCC.ST, x);             (*    ST  Dn *)
  302.     OCC.PutWord (6002H);                                     (*    BRA 2$ *)
  303.     OCC.FixLink (L0); OCC.PutF3 (OCC.SF, x);                 (* 1$ SF  Dn *)
  304.   END                                                        (* 2$        *)
  305. END loadB;
  306.  
  307. (*------------------------------------*)
  308. PROCEDURE setCC * (VAR x: OCT.Item; cc : LONGINT);
  309.  
  310. BEGIN (* setCC *)
  311.   x.typ := OCT.booltyp; x.mode := Coc; x.a0 := cc; x.a1 := 0; x.a2 := 0
  312. END setCC;
  313.  
  314. (*------------------------------------*)
  315. PROCEDURE cmp (VAR lhs, rhs : OCT.Item; freeX : BOOLEAN);
  316.  
  317.   VAR size : LONGINT;
  318.  
  319. BEGIN (* cmp *)
  320.   size := lhs.typ.size; IF size > L THEN size := L END;
  321.   IF rhs.mode = Con THEN
  322.     IF lhs.mode = Con THEN OCI.Load (lhs)
  323.     ELSIF lhs.mode = Coc THEN loadB (lhs)
  324.     END;
  325.     IF rhs.a0 = 0 THEN OCC.PutF1 (OCC.TST, size, lhs)
  326.     ELSE OCC.PutF6 (OCC.CMPI, size, rhs, lhs)
  327.     END
  328.   ELSE
  329.     IF lhs.mode = Coc THEN loadB (lhs)
  330.     ELSE OCI.Load (lhs)
  331.     END;
  332.     OCC.PutF5 (OCC.CMP, size, rhs, lhs);
  333.   END;
  334.   IF freeX THEN OCI.Unload (lhs) END
  335. END cmp;
  336.  
  337. (*------------------------------------*)
  338. PROCEDURE test (VAR x : OCT.Item);
  339.  
  340. BEGIN (* test *)
  341.   OCC.PutF1 (OCC.TST, x.typ.size, x); OCI.Unload (x); setCC (x, OCC.NE)
  342. END test;
  343.  
  344. (*------------------------------------*)
  345. PROCEDURE SetIntType * (VAR x : OCT.Item);
  346.  
  347.   VAR v : LONGINT;
  348.  
  349. BEGIN (* SetIntType *)
  350.   v := x.a0;
  351.   IF (LONG (OCM.MinSInt) <= v) & (v <= LONG (OCM.MaxSInt)) THEN
  352.     x.typ := OCT.sinttyp
  353.   ELSIF (LONG (OCM.MinInt) <= v) & (v <= LONG (OCM.MaxInt)) THEN
  354.     x.typ := OCT.inttyp
  355.   ELSE
  356.     x.typ := OCT.linttyp
  357.   END;
  358. END SetIntType;
  359.  
  360. (*------------------------------------*)
  361. PROCEDURE SetSetType (VAR x : OCT.Item);
  362.  
  363.   VAR s : SET;
  364.  
  365. BEGIN (* SetSetType *)
  366.   s := SYS.VAL (SET, x.a0);
  367.   IF (s - {OCM.MinSet .. OCM.MaxBSet}) = {} THEN
  368.     x.typ := OCT.bsettyp
  369.   ELSIF (s - {OCM.MinSet .. OCM.MaxWSet}) = {} THEN
  370.     x.typ := OCT.wsettyp
  371.   ELSE
  372.     x.typ := OCT.settyp
  373.   END
  374. END SetSetType;
  375.  
  376. (*------------------------------------*)
  377. PROCEDURE AssReal * (VAR x : OCT.Item; y : REAL);
  378.  
  379. BEGIN (* AssReal *)
  380.   SYS.PUT (SYS.ADR (x.a0), y)
  381. END AssReal;
  382.  
  383. (*------------------------------------*)
  384. PROCEDURE AssLReal * (VAR x : OCT.Item; y : LONGREAL);
  385.  
  386. BEGIN (* AssLReal *)
  387.   SYS.PUT (SYS.ADR (x.a0), y)
  388. END AssLReal;
  389.  
  390. (*------------------------------------*)
  391. PROCEDURE Index * (VAR x, y : OCT.Item);
  392.  
  393.   VAR
  394.     f, m, r : INTEGER; L0, i, n : LONGINT;
  395.     eltyp : OCT.Struct; t1, t2 : OCT.Item;
  396.     desc : OCT.Desc; wordSize, calcSize, ovflChk : BOOLEAN;
  397.  
  398. BEGIN (* Index *)
  399.   ovflChk := OCS.pragma [OCS.ovflChk]; OCS.pragma [OCS.ovflChk] := FALSE;
  400.   f := y.typ.form;
  401.   IF ~(f IN intSet) THEN OCS.Mark (80); y.typ := OCT.inttyp END;
  402.   IF x.typ = NIL THEN OCS.Mark (80); HALT (80) END;
  403.   IF x.typ.form = Array THEN
  404.     eltyp := x.typ.BaseTyp; n := x.typ.n;
  405.     wordSize := (x.typ.size <= 32767);
  406.     IF eltyp = NIL THEN OCS.Mark (81); HALT (81) END;
  407.     IF y.mode = Con THEN
  408.       IF (0 <= y.a0) & (y.a0 < n) THEN i := y.a0 * eltyp.size
  409.       ELSE OCS.Mark (81); i := 0
  410.       END;
  411.       IF x.mode = Var  THEN INC (x.a0, i)
  412.       ELSIF x.mode = RegI THEN INC (x.a1, i)
  413.       ELSE OCI.LoadAdr (x); x.a1 := i
  414.       END;
  415.       IF x.obj # OCC.wasderef THEN x.obj := NIL END;
  416.     ELSE
  417.       OCI.Load (y);
  418.       IF f = SInt THEN
  419.         OCI.EXT (W, y.a0); y.typ := OCT.inttyp; f := Int
  420.       END;
  421.       IF (n > 32767) & (f = Int) THEN
  422.         OCI.EXT (L, y.a0); y.typ := OCT.linttyp; f := LInt
  423.       END;
  424.  
  425.       IF OCS.pragma [OCS.indexChk] THEN (* t1 = bound descr *)
  426.         t1.mode := Con; t1.a0 := n - 1;
  427.         IF f = Int THEN t1.typ := OCT.inttyp; OCC.PutCHK (t1, y.a0)
  428.         ELSE
  429.           OCC.PutF1 (OCC.TST, L, y);             (*    TST.L Dy          *)
  430.           L0 := OCC.pc; OCC.PutWord (6B00H);     (*    BMI.S 1$          *)
  431.           t1.typ := OCT.linttyp;
  432.           cmp (y, t1, FALSE);                    (*    CMP.L #t1,Dy      *)
  433.           OCC.TrapLink (OCC.IndexCheck, OCC.GT, L0);
  434.                                                  (*    BLE.S 2$          *)
  435.                                                  (* 1$ TRAP  #IndexCheck *)
  436.         END                                      (* 2$                   *)
  437.       END;
  438.  
  439.       m := x.mode;
  440.       IF m = Var THEN
  441.         IF OCC.InAdrReg (x.obj) THEN
  442.           OCC.GetAReg (t1, x.obj)
  443.         ELSE
  444.           OCC.GetAReg (t1, x.obj); t2 := x;
  445.           OCC.PutF2 (OCC.LEA, t2, t1.a0); OCI.Unload (t2)
  446.         END;
  447.         x.mode := RegX; x.a0 := t1.a0; x.a1 := 0; x.a2 := y.a0;
  448.         x.wordIndex := wordSize; calcSize := eltyp.size > 1
  449.       ELSIF m = Ind THEN
  450.         IF OCC.InAdrReg (x.obj) THEN
  451.           OCC.GetAReg (t1, x.obj)
  452.         ELSE
  453.           OCC.GetAReg (t1, x.obj); t2 := x; t2.mode := Var;
  454.           OCC.Move (L, t2, t1); OCI.Unload (t2)
  455.         END;
  456.         x.mode := RegX; x.a0 := t1.a0; x.a2 := y.a0;
  457.         x.wordIndex := wordSize; calcSize := eltyp.size > 1
  458.       ELSIF m = RegI THEN
  459.         x.mode := RegX; x.wordIndex := wordSize; x.a2 := y.a0;
  460.         calcSize := eltyp.size > 1;
  461.       ELSIF m IN {VarX, IndX, RegX} THEN
  462.         IF eltyp.size > 1 THEN
  463.           t1.mode := Con; t1.a0 := eltyp.size;
  464.           IF x.wordIndex THEN t1.typ := OCT.inttyp
  465.           ELSE t1.typ := OCT.linttyp
  466.           END;
  467.           Op (times, y, t1, FALSE)
  468.         END;
  469.         t1 := y; y.mode := Reg; y.a0 := x.a2;
  470.         IF x.wordIndex THEN y.typ := OCT.inttyp
  471.         ELSE y.typ := OCT.linttyp
  472.         END;
  473.         Op (plus, y, t1, TRUE);
  474.         calcSize := FALSE;
  475.       ELSE OCS.Mark (322)
  476.       END;
  477.       IF x.obj # OCC.wasderef THEN x.obj := NIL END;
  478.       IF calcSize THEN
  479.         t1.mode := Con; t1.a0 := eltyp.size;
  480.         IF x.wordIndex THEN t1.typ := OCT.inttyp
  481.         ELSE t1.typ := OCT.linttyp
  482.         END;
  483.         Op (times, y, t1, FALSE)
  484.       END
  485.     END; (* ELSE *)
  486.     x.typ := eltyp
  487.   ELSIF x.typ.form = DynArr THEN
  488.     IF f # LInt THEN ConvertInts (y, OCT.linttyp)
  489.     ELSIF y.mode # Con THEN OCI.Load (y)
  490.     END;
  491.  
  492.     IF OCS.pragma [OCS.indexChk] THEN
  493.       IF (y.mode = Con) & (y.a0 < 0) THEN OCS.Mark (81)
  494.       ELSE
  495.         (* t1 = bound descr *)
  496.         OCI.DescItem (t1, x.desc, x.typ.adr);
  497.         IF y.mode # Con THEN
  498.           OCC.PutF1 (OCC.TST, L, y);             (*    TST.L y           *)
  499.           L0 := OCC.pc; OCC.PutWord (6B00H);     (*    BMI.S 1$          *)
  500.           cmp (y, t1, FALSE);                    (*    CMP.L t1,Dy       *)
  501.           OCC.TrapLink (OCC.IndexCheck, OCC.GE, L0);
  502.                                                  (*    BLT.S 2$          *)
  503.                                                  (* 1$ TRAP  #IndexCheck *)
  504.                                                  (* 2$                   *)
  505.         ELSE
  506.           cmp (t1, y, FALSE);                    (*    CMP.L y,t1        *)
  507.           OCC.TrapCC (OCC.IndexCheck, OCC.LE);   (*    BGT.S 1$          *)
  508.                                                  (*    TRAP  #IndexCheck *)
  509.                                                  (* 1$                   *)
  510.         END;
  511.         OCI.UpdateDesc (t1, x.typ.adr)
  512.       END (* ELSE *)
  513.     END; (* IF *)
  514.  
  515.     IF x.mode IN {Var, Ind} THEN
  516.       IF OCC.InAdrReg (x.obj) THEN
  517.         OCC.GetAReg (t1, x.obj)
  518.       ELSE
  519.         OCC.GetAReg (t1, x.obj); t2 := x; t2.mode := Var;
  520.         OCC.Move (L, t2, t1); OCI.Unload (t2)
  521.       END;
  522.       IF y.mode = Con THEN
  523.         x.mode := RegI; x.a0 := t1.a0; x.a1 := y.a0
  524.       ELSE
  525.         x.mode := RegX; x.a0 := t1.a0; x.a2 := y.a0;
  526.         x.wordIndex := FALSE
  527.       END
  528.     ELSIF x.mode = RegI THEN (* Dereferenced ptr *)
  529.       IF y.mode = Con THEN x.a1 := y.a0
  530.       ELSE x.mode := RegX; x.a2 := y.a0; x.wordIndex := FALSE
  531.       END
  532.     ELSIF x.mode IN {IndX, RegX} THEN (* Indexed open array *)
  533.       IF ~OCS.pragma [OCS.indexChk] THEN (* t1 = bound descr *)
  534.         OCI.DescItem (t1, x.desc, x.typ.adr);
  535.       END;
  536.       t2.mode := Reg; t2.a0 := x.a2; t2.typ := OCT.linttyp;
  537.       Op (times, t2, t1, FALSE); Op (plus, t2, y, TRUE); y := t2;
  538.       OCI.UpdateDesc (t1, x.typ.adr)
  539.     ELSE OCS.Mark (322)
  540.     END;
  541.     IF x.obj # OCC.wasderef THEN x.obj := NIL END;
  542.  
  543.     x.typ := x.typ.BaseTyp;
  544.     IF x.typ # NIL THEN
  545.       IF (x.typ.form # DynArr) THEN
  546.         IF x.typ.size > 1 THEN
  547.           t1.mode := Con; t1.a0 := x.typ.size; SetIntType (t1);
  548.           Op (times, y, t1, FALSE)
  549.         END;
  550.         IF y.mode = Con THEN x.a1 := y.a0 END
  551.       ELSIF (y.mode = Con) & (y.a0 # 0) THEN
  552.         OCI.Load (y); x.a1 := 0; x.a2 := y.a0; x.wordIndex := FALSE;
  553.         IF x.mode = Ind THEN x.mode := IndX
  554.         ELSIF x.mode = RegI THEN x.mode := RegX
  555.         ELSE OCS.Mark (322)
  556.         END
  557.       END
  558.     END
  559.   ELSE
  560.     OCS.Mark (82)
  561.   END;
  562.   OCS.pragma [OCS.ovflChk] := ovflChk
  563. END Index;
  564.  
  565. (*------------------------------------*)
  566. PROCEDURE Field * (VAR x : OCT.Item; y : OCT.Object);
  567.  
  568.   VAR t1, t2 : OCT.Item;
  569.  
  570. BEGIN (* Field *)
  571.   IF x.mode = Var THEN
  572.     INC (x.a0, y.a0)
  573.   ELSIF x.mode = Ind THEN
  574.     IF OCC.InAdrReg (x.obj) THEN
  575.       OCC.GetAReg (t1, x.obj)
  576.     ELSE
  577.       OCC.GetAReg (t1, x.obj); t2 := x; t2.mode := Var;
  578.       OCC.Move (L, t2, t1); OCI.Unload (t2)
  579.     END;
  580.     x.mode := RegI; x.a0 := t1.a0; INC (x.a1, y.a0)
  581.   ELSIF x.mode = RegI THEN
  582.     INC (x.a1, y.a0)
  583.   ELSE
  584.     OCI.LoadAdr (x); x.mode := RegI; x.a1 := y.a0
  585.   END;
  586.   x.typ := y.typ; x.obj := NIL;
  587.   IF x.lev < 0 THEN x.rdOnly := x.rdOnly OR (y.visible = OCT.RdOnly) END
  588. END Field;
  589.  
  590. (*------------------------------------*)
  591. PROCEDURE DeRef * (VAR x : OCT.Item; load : BOOLEAN);
  592.  
  593.   VAR
  594.     y, z : OCT.Item; flg : INTEGER; desc : OCT.Desc; freeY : BOOLEAN;
  595.     btyp : OCT.Struct;
  596.  
  597. BEGIN (* DeRef *)
  598.   IF (x.mode <= RegX) & (x.typ.form = Pointer) THEN
  599.     OCI.UnloadDesc (x); flg := x.typ.sysflg; btyp := x.typ.BaseTyp;
  600.     IF (flg = OberonFlag) & (btyp # NIL) & (btyp.form = DynArr)
  601.     THEN
  602.       desc := x.desc; IF desc = NIL THEN NEW (desc) END;
  603.       desc.lev := x.lev; desc.mode := x.mode; desc.a0 := x.a0;
  604.       desc.a1 := x.a1; desc.a2 := x.a2;
  605.       freeY := ~(desc.mode IN {VarX, IndX, RegI, RegX})
  606.     ELSE
  607.       desc := NIL; freeY := TRUE
  608.     END;
  609.     IF OCC.InAdrReg (x.obj) THEN
  610.       OCC.GetAReg (x, x.obj); x.desc := desc; x.mode := RegI
  611.     ELSE
  612.       IF flg = BCPLFlag THEN
  613.         y := x; y.obj := NIL; OCC.GetDReg (z, NIL);
  614.         OCC.Move (L, y, z); OCI.Unload (y);             (* MOVE.L  x,Dm   *)
  615.         IF OCS.pragma [OCS.nilChk] THEN OCC.TrapCC (OCC.NilCheck, OCC.EQ)
  616.         END;
  617.         OCC.PutF5 (OCC.ADD, L, z, z);                   (* ADD.L   Dm, Dm *)
  618.         OCC.PutF5 (OCC.ADD, L, z, z);                   (* ADD.L   Dm, Dm *)
  619.         OCC.GetAReg (x, x.obj); OCC.Move (L, z, x);     (* MOVEA.L Dm,An  *)
  620.         OCI.Unload (z); x.mode := RegI
  621.       ELSE
  622.         y.mode := Undef; x.desc := desc;
  623.         IF ~load & (x.mode = Var) THEN
  624.           y := x;
  625.           IF OCS.pragma [OCS.nilChk] THEN
  626.             OCC.PutF1 (OCC.TST, L, y);                  (* TST.L x        *)
  627.             OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  628.           END;
  629.           x.mode := Ind
  630.         ELSE
  631.           y := x; y.obj := NIL; y.typ := OCT.ptrtyp; OCC.GetAReg (x, x.obj);
  632.           IF OCS.pragma [OCS.nilChk] THEN
  633.             OCC.GetDReg (z, NIL); OCC.Move (L, y, z);   (* MOVE.L  x,Dn   *)
  634.             OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  635.             OCC.Move (L, z, x); OCI.Unload (z)          (* MOVEA.L Dn, An *)
  636.           ELSE
  637.             OCC.Move (L, y, x);                         (* MOVEA.L x, An  *)
  638.           END;
  639.           IF freeY THEN OCI.Unload (y) END; x.mode := RegI
  640.         END
  641.       END
  642.     END;
  643.     x.typ := x.typ.BaseTyp; x.obj := OCC.wasderef; x.rdOnly := FALSE;
  644.     x.a2 := 0
  645.   ELSE
  646.     OCS.Mark (84)
  647.   END;
  648.   x.a1 := 0
  649. END DeRef;
  650.  
  651. (*------------------------------------*)
  652. PROCEDURE TypTest * (VAR x, y : OCT.Item; test : BOOLEAN);
  653.  
  654.   (*------------------------------------*)
  655.   PROCEDURE GTT (t0, t1 : OCT.Struct; varpar : BOOLEAN);
  656.  
  657.     VAR t : OCT.Struct; xt, tdes, x1 : OCT.Item;
  658.  
  659.     (*------------------------------------*)
  660.     PROCEDURE DeRef (VAR x : OCT.Item);
  661.  
  662.       VAR y, z : OCT.Item;
  663.  
  664.     BEGIN (* DeRef *)
  665.       IF OCC.InAdrReg (x.obj) THEN
  666.         OCC.GetAReg (x, x.obj)
  667.       ELSE
  668.         y := x; y.obj := NIL; y.typ := OCT.ptrtyp; OCC.GetAReg (x, x.obj);
  669.         IF OCS.pragma [OCS.nilChk] THEN
  670.           OCC.GetDReg (z, NIL); OCC.Move (L, y, z);   (* MOVE.L  x,Dn   *)
  671.           OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  672.           OCC.Move (L, z, x); OCI.Unload (z)          (* MOVEA.L Dn, An *)
  673.         ELSE
  674.           OCC.Move (L, y, x)                          (* MOVEA.L x, An  *)
  675.         END
  676.       END;
  677.       x.mode := RegI; x.a1 := 0; x.a2 := 0; x.rdOnly := FALSE
  678.     END DeRef;
  679.  
  680.   BEGIN (* GTT *)
  681.     IF t0 # t1 THEN
  682.       t := t1;
  683.       IF t0.form = Record THEN
  684.         REPEAT t := t.BaseTyp UNTIL (t = NIL) OR (t = t0);
  685.       END;
  686.       IF t # NIL THEN
  687.         x.typ := y.typ;
  688.         IF OCS.pragma [OCS.typeChk] OR test THEN
  689.           IF varpar THEN
  690.             xt := x; xt.mode := Ind; xt.a0 := x.a0 + 4; xt.obj := NIL
  691.           ELSE
  692.             x1 := x; DeRef (x1); x1.a1 := -4; OCC.GetAReg (xt, NIL);
  693.             OCC.Move (L, x1, xt); OCI.Unload (x1); xt.mode := RegI
  694.           END;
  695.           xt.a1 := (t1.n + 1) * 4; xt.typ := OCT.tagtyp;
  696.           tdes.mode := Con; tdes.a0 := 0; tdes.a1 := 0;
  697.           tdes.label := t1.label; tdes.typ := OCT.tagtyp;
  698.           OCI.Adr (tdes); OCI.CMP (L, tdes, xt);  (*    CMP.L  tdes,<xt> *)
  699.           OCI.Unload (tdes); OCI.Unload (xt);
  700.           IF ~test THEN OCC.TrapCC (OCC.TypeCheck, OCC.NE)
  701.           ELSE setCC (x, OCC.EQ)
  702.           END
  703.         END
  704.       ELSE OCS.Mark (85); IF test THEN x.typ := OCT.booltyp END
  705.       END
  706.     ELSIF test THEN setCC (x, OCC.T)
  707.     END
  708.   END GTT;
  709.  
  710. BEGIN (* TypTest *)
  711.   IF (x.typ.form = Pointer) & (x.typ.sysflg = OberonFlag) THEN
  712.     IF (y.typ.form = Pointer) & (y.typ.sysflg = OberonFlag) THEN
  713.       GTT (x.typ.BaseTyp, y.typ.BaseTyp, FALSE)
  714.     ELSE OCS.Mark (86)
  715.     END
  716.   ELSIF x.typ.form = PtrTyp THEN
  717.     IF
  718.       (y.typ.form = Pointer) & (y.typ.sysflg = OberonFlag)
  719.       & (y.typ.BaseTyp # NIL) & (y.typ.BaseTyp.form # DynArr)
  720.     THEN
  721.       GTT (x.typ, y.typ.BaseTyp, FALSE)
  722.     ELSE OCS.Mark (86)
  723.     END
  724.   ELSIF
  725.     (x.typ.form = Record) & (x.typ.sysflg = OberonFlag)
  726.     & (x.mode = Ind) & (x.obj # NIL) & (x.obj # OCC.wasderef)
  727.     & (y.typ.form = Record) & (y.typ.sysflg = OberonFlag)
  728.   THEN
  729.     GTT (x.typ, y.typ, TRUE)
  730.   ELSE OCS.Mark (87)
  731.   END
  732. END TypTest;
  733.  
  734. (*------------------------------------*)
  735. PROCEDURE In * (VAR lhs, rhs : OCT.Item);
  736.  
  737.   VAR f, g : INTEGER; L0 : LONGINT; bnd, br : OCT.Item;
  738.  
  739. BEGIN (* In *)
  740.   f := lhs.typ.form; g := rhs.typ.form;
  741.   IF (f IN intSet) & (g IN setSet) THEN
  742.     IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  743.       IF (lhs.a0 >= 0) & (lhs.a0 < 32) THEN
  744.         IF lhs.a0 IN SYS.VAL (SET, rhs.a0) THEN setCC (lhs, OCC.T)
  745.         ELSE setCC (lhs, OCC.F)
  746.         END
  747.       ELSE
  748.         OCS.Mark (91); setCC (lhs, OCC.F)
  749.       END
  750.     ELSIF lhs.mode = Con THEN
  751.       IF
  752.         (lhs.a0 < 0)
  753.         OR ((g = BSet) & (lhs.a0 > 7))
  754.         OR ((g = WSet) & (lhs.a0 > 15))
  755.         OR ((g = Set) & (lhs.a0 > 31))
  756.       THEN
  757.         OCS.Mark (91); setCC (lhs, OCC.F)
  758.       ELSE
  759.         OCI.Load (rhs); OCC.Bit (OCC.BTST, lhs, rhs);
  760.         OCI.Unload (rhs); setCC (lhs, OCC.NE)
  761.       END; (* ELSE *)
  762.     ELSE
  763.       IF rhs.mode = Con THEN rhs.typ := OCT.settyp; g := Set END;
  764.       OCI.Load (lhs);
  765.  
  766.       IF OCS.pragma [OCS.rangeChk] THEN
  767.         IF lhs.typ.form = SInt THEN OCI.EXT (W, lhs.a0) END;
  768.         bnd.mode := Con;
  769.         IF g = BSet THEN bnd.a0 := 7
  770.         ELSIF g = WSet THEN bnd.a0 := 15
  771.         ELSE bnd.a0 := 31
  772.         END;
  773.         IF lhs.typ.form = LInt THEN
  774.           bnd.typ := OCT.linttyp;
  775.           OCC.PutF1 (OCC.TST, L, lhs);            (*    TST.L <lhs>       *)
  776.           L0 := OCC.pc; OCC.PutWord (6B00H);      (*    BMI.S 1$          *)
  777.           cmp (lhs, bnd, FALSE);                  (*    CMP   #<bnd>,<lhs>*)
  778.           OCC.TrapLink (OCC.IndexCheck, OCC.GT, L0);
  779.                                                   (*    BLE.S 2$          *)
  780.                                                   (* 1$ TRAP  #IndexCheck *)
  781.         ELSE                                      (* 2$                   *)
  782.           bnd.typ := OCT.inttyp; OCC.PutCHK (bnd, lhs.a0)
  783.         END
  784.       END;
  785.  
  786.       OCI.Load (rhs); OCC.Bit (OCC.BTST, lhs, rhs);
  787.       OCI.Unload (lhs); OCI.Unload (rhs); setCC (lhs, OCC.NE)
  788.     END
  789.   ELSE OCS.Mark (92); setCC (lhs, OCC.F)
  790.   END
  791. END In;
  792.  
  793. (*------------------------------------*)
  794. PROCEDURE Set0 * (VAR x, y : OCT.Item);
  795.  
  796.   VAR one : LONGINT;
  797.  
  798. BEGIN (* Set0 *)
  799.   x.mode := Reg; x.a0 := D0; x.typ := OCT.settyp;
  800.   IF y.typ.form IN intSet THEN
  801.     IF y.mode = Con THEN
  802.       x.mode := Con;
  803.       IF (0 <= y.a0) & (y.a0 < 32) THEN
  804.         one := 1; x.a0 := SYS.LSH (one, y.a0); SetSetType (x)
  805.       ELSE
  806.         OCS.Mark (202)
  807.       END
  808.     ELSE
  809.       x.mode := Con; x.a0 := 1; OCI.Load (x); OCI.Load (y);
  810.       OCC.Shift (OCC.LSL, L, y, x); OCI.Unload (y)
  811.     END
  812.   ELSE OCS.Mark (93)
  813.   END
  814. END Set0;
  815.  
  816. (*------------------------------------*)
  817. PROCEDURE Set1 * (VAR x, y, z : OCT.Item);
  818.  
  819.   VAR s : LONGINT;
  820.  
  821. BEGIN (* Set1 *)
  822.   x.mode := Reg; x.a0 := D0; x.typ := OCT.settyp;
  823.   IF
  824.     (y.typ.form IN intSet) & (z.typ.form IN intSet)
  825.   THEN
  826.     IF y.mode = Con THEN
  827.       IF (0 <= y.a0) & (y.a0 < 32) THEN
  828.         y.typ := OCT.settyp; s := -1; y.a0 := SYS.LSH (s, y.a0);
  829.         IF z.mode = Con THEN
  830.           x.mode := Con;
  831.           IF (y.a0 <= z.a0) & (z.a0 < 32) THEN
  832.             s := -2; x.a0 := y.a0 - SYS.LSH (s, z.a0); SetSetType (x)
  833.           ELSE
  834.             OCS.Mark (202); x.a0 := 0
  835.           END
  836.         ELSIF y.a0 = -1 THEN
  837.           x.mode := Con; x.a0 := -2; OCI.Load (x); OCI.Load (z);
  838.           OCC.Shift (OCC.LSL, L, z, x); OCC.PutF1 (OCC.NOT, L, x);
  839.           OCC.FreeReg (z)
  840.         ELSE
  841.           x := y; y.mode := Con; y.a0 := -2; OCI.Load (y); OCI.Load (z);
  842.           OCC.Shift (OCC.LSL, L, z, y); OCC.FreeReg (z);
  843.           OCC.PutF1 (OCC.NOT, L, y); OCI.Load (x);
  844.           OCC.PutF5 (OCC.AND, L, y, x); OCC.FreeReg (y)
  845.         END
  846.       ELSE
  847.         OCS.Mark (202)
  848.       END
  849.     ELSE
  850.       x.mode := Con; x.a0 := -1; OCI.Load (x); OCI.Load (y);
  851.       OCC.Shift (OCC.LSL, L, y, x); OCC.FreeReg (y);
  852.       y.mode := Con; y.typ := NIL;
  853.       IF z.mode = Con THEN
  854.         IF (0 <= z.a0) & (z.a0 < 32) THEN
  855.           s := -2;
  856.           y.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, SYS.LSH(s, z.a0)));
  857.           OCC.PutF6 (OCC.ANDI, L, y, x)
  858.         ELSE
  859.           OCS.Mark (202)
  860.         END
  861.       ELSE
  862.         y.a0 := -2; OCI.Load (y); OCI.Load (z);
  863.         OCC.Shift (OCC.LSL, L, z, y); OCC.FreeReg (z);
  864.         OCC.PutF1 (OCC.NOT, L, y); OCC.PutF5 (OCC.AND, L, y, x);
  865.         OCC.FreeReg (y)
  866.       END
  867.     END (* ELSE *)
  868.   ELSE
  869.     OCS.Mark (93)
  870.   END
  871. END Set1;
  872.  
  873. (*------------------------------------*)
  874. PROCEDURE MOp * (op : INTEGER; VAR x : OCT.Item);
  875.  
  876.   VAR f : INTEGER; a, opcode : LONGINT; y : OCT.Item; freeY : BOOLEAN;
  877.  
  878. BEGIN (* MOp *)
  879.   f := x.typ.form;
  880.   CASE op OF
  881.     and :
  882.       IF (x.typ.form = Bool) & (x.mode = Con) THEN
  883.         IF x.a0 = 0 THEN setCC (x, OCC.F) ELSE setCC (x, OCC.T) END
  884.       END;
  885.       IF x.mode = Coc THEN
  886.         IF x.a0 # OCC.T THEN
  887.           IF x.a0 = OCC.F THEN opcode := OCC.BRA
  888.           ELSE opcode := OCC.Bcc + (OCC.invertedCC (x.a0) * 100H)
  889.           END;
  890.           OCC.PutWord (opcode); OCC.PutWord (x.a2); x.a2 := OCC.pc - 2
  891.         END;
  892.         OCC.FixLink (x.a1)
  893.       ELSIF x.typ.form = Bool THEN
  894.         test (x); OCC.PutWord (OCC.BEQ); OCC.PutWord (x.a2);
  895.         x.a2 := OCC.pc - 2; OCC.FixLink (x.a1)
  896.       ELSE
  897.         OCS.Mark (94); x.mode := Con; x.typ := OCT.booltyp; x.a0 := 0
  898.       END
  899.     |
  900.     plus :
  901.       IF ~(f IN intSet + realSet) THEN OCS.Mark (96) END
  902.     |
  903.     minus :
  904.       IF f IN intSet THEN
  905.         IF x.mode = Con THEN x.a0 := -x.a0; SetIntType (x)
  906.         ELSE OCI.Load (x); OCC.PutF1 (OCC.NEG, x.typ.size, x)
  907.         END
  908.       ELSIF f IN realSet THEN
  909.         IF x.mode = Con THEN
  910.           x.a0 := SYS.VAL (LONGINT, - SYS.VAL (REAL, x.a0))
  911.         ELSE
  912.           NegReal (x)
  913.         END
  914.       ELSIF f IN setSet THEN
  915.         IF x.mode = Con THEN
  916.           x.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, x.a0))
  917.         ELSE
  918.           OCI.Load (x); OCC.PutF1 (OCC.NOT, x.typ.size, x)
  919.         END
  920.       ELSE
  921.         OCS.Mark (97)
  922.       END
  923.     |
  924.     or :
  925.       IF (x.typ.form = Bool) & (x.mode = Con) THEN
  926.         IF x.a0 = 0 THEN setCC (x, OCC.F) ELSE setCC (x, OCC.T) END
  927.       END; (* IF *)
  928.       IF x.mode = Coc THEN
  929.         IF x.a0 # OCC.F THEN
  930.           IF x.a0 = OCC.T THEN opcode := OCC.BRA
  931.           ELSE opcode := OCC.Bcc + (x.a0 * 100H)
  932.           END;
  933.           OCC.PutWord (opcode); OCC.PutWord (x.a1);
  934.           x.a1 := OCC.pc - 2
  935.         END;
  936.         OCC.FixLink (x.a2)
  937.       ELSIF x.typ.form = Bool THEN
  938.         test (x); OCC.PutWord (OCC.BNE); OCC.PutWord (x.a1);
  939.         x.a1 := OCC.pc - 2; OCC.FixLink (x.a2)
  940.       ELSE
  941.         OCS.Mark (94); x.mode := Con; x.typ := OCT.booltyp; x.a0 := 1
  942.       END
  943.     |
  944.     eql .. geq : (* relations *)
  945.       IF x.mode = Coc THEN loadB (x) END
  946.     |
  947.     not :
  948.       IF x.typ.form = Bool THEN
  949.         IF x.mode = Con THEN
  950.           IF x.a0 = 0 THEN x.a0 := 1 ELSE x.a0 := 0 END
  951.         ELSIF x.mode = Coc THEN
  952.           x.a0 := OCC.invertedCC (x.a0); a := x.a1; x.a1 := x.a2;
  953.           x.a2 := a
  954.         ELSE
  955.           y := x;
  956.           OCC.PutF1 (OCC.TST, B, y); setCC (x, OCC.EQ);
  957.         END
  958.       ELSE
  959.         OCS.Mark (98)
  960.       END
  961.     |
  962.   ELSE
  963.     OCS.Mark (1010); OCS.Mark (op)
  964.   END; (* CASE op *)
  965. END MOp;
  966.  
  967. (*------------------------------------*)
  968. PROCEDURE CheckOverflow (op : INTEGER; VAR lhs, rhs : OCT.Item);
  969.  
  970.   CONST min = OCM.MinLInt; max = OCM.MaxLInt;
  971.  
  972. BEGIN (* CheckOverflow *)
  973.   CASE op OF
  974.     times :
  975.       IF lhs.a0 < 0 THEN
  976.         IF (rhs.a0 < 0) & (lhs.a0 < max DIV rhs.a0) THEN
  977.           OCS.Mark (109); rhs.a0 := -1
  978.         ELSIF (rhs.a0 > 0) & (lhs.a0 < min DIV rhs.a0) THEN
  979.           OCS.Mark (109); rhs.a0 := 1
  980.         END
  981.       ELSE
  982.         IF (rhs.a0 < 0) & (lhs.a0 > min DIV rhs.a0) THEN
  983.           OCS.Mark (109); rhs.a0 := -1
  984.         ELSIF (rhs.a0 > 0) & (lhs.a0 > max DIV rhs.a0) THEN
  985.           OCS.Mark (109); rhs.a0 := 1
  986.         END
  987.       END
  988.     |
  989.     plus :
  990.       IF lhs.a0 < 0 THEN
  991.         IF (rhs.a0 < 0) & (lhs.a0 < min - rhs.a0) THEN
  992.           OCS.Mark (109); rhs.a0 := 0
  993.         END
  994.       ELSE
  995.         IF (rhs.a0 > 0) & (lhs.a0 > max - rhs.a0) THEN
  996.           OCS.Mark (109); rhs.a0 := 0
  997.         END
  998.       END
  999.     |
  1000.     minus :
  1001.       IF lhs.a0 < 0 THEN
  1002.         IF (rhs.a0 > 0) & (lhs.a0 < min + rhs.a0) THEN
  1003.           OCS.Mark (109); rhs.a0 := 0
  1004.         END
  1005.       ELSE
  1006.         IF (rhs.a0 < 0) & (lhs.a0 > max + rhs.a0) THEN
  1007.           OCS.Mark (109); rhs.a0 := 0
  1008.         END
  1009.       END
  1010.     |
  1011.   ELSE
  1012.     OCS.Mark (1011); OCS.Mark (op)
  1013.   END; (* CASE op *)
  1014. END CheckOverflow;
  1015.  
  1016. (*------------------------------------*)
  1017. PROCEDURE Op * (op : INTEGER; VAR lhs, rhs : OCT.Item; freeRegs : BOOLEAN);
  1018.  
  1019.   CONST
  1020.     eqSet = { Undef, Char .. LInt, BSet .. Set,
  1021.               NilTyp, PtrTyp .. ProcTyp, TagTyp };
  1022.     nilSet = { Pointer, PtrTyp, AdrTyp, BPtrTyp, ProcTyp, TagTyp };
  1023.  
  1024.   VAR f, g : INTEGER; p, q, r : OCT.Struct; size : LONGINT;
  1025.  
  1026.   (*------------------------------------*)
  1027.   PROCEDURE strings () : BOOLEAN;
  1028.  
  1029.   BEGIN (* strings *)
  1030.     RETURN
  1031.       ((((f = Array) OR (f = DynArr)) & (lhs.typ.BaseTyp.form = Char))
  1032.        OR (f = String))
  1033.       & ((((g = Array) OR (g = DynArr)) & (rhs.typ.BaseTyp.form = Char))
  1034.        OR (g = String))
  1035.   END strings;
  1036.  
  1037.   (*------------------------------------*)
  1038.   PROCEDURE CompStrings (cc : INTEGER; testNul : BOOLEAN);
  1039.  
  1040.     VAR br, len, ch : OCT.Item; L0, L1 : LONGINT; d : OCT.Desc;
  1041.  
  1042.   BEGIN (* CompStrings *)
  1043.     IF (g = String) & (rhs.a1 = 1) THEN
  1044.       IF (f = String) & (lhs.a1 <= 2) THEN
  1045.         OCC.AllocStringFromChar (lhs)
  1046.       END;
  1047.       IF cc = OCC.CS THEN setCC (lhs, OCC.F)
  1048.       ELSIF cc = OCC.CC THEN setCC (lhs, OCC.T)
  1049.       ELSE
  1050.         IF (f = DynArr) & (lhs.mode = Var) THEN lhs.mode := Ind END;
  1051.         OCC.PutF1 (OCC.TST, B, lhs);               (*    TST.B   <lhs>    *)
  1052.         OCI.Unload (lhs); setCC (lhs, cc)
  1053.       END
  1054.     ELSIF (f = String) & (lhs.a1 = 1) THEN
  1055.       IF cc = OCC.CS THEN cc := OCC.HI
  1056.       ELSIF cc = OCC.HI THEN cc := OCC.CS
  1057.       ELSIF cc = OCC.CC THEN cc := OCC.LS
  1058.       ELSIF cc = OCC.LS THEN cc := OCC.CC
  1059.       END;
  1060.       IF cc = OCC.CS THEN setCC (lhs, OCC.F)
  1061.       ELSIF cc = OCC.CC THEN setCC (lhs, OCC.T)
  1062.       ELSE
  1063.         IF (g = DynArr) & (rhs.mode = Var) THEN rhs.mode := Ind END;
  1064.         OCC.PutF1 (OCC.TST, B, rhs);               (*    TST.B   <rhs>    *)
  1065.         setCC (lhs, cc)
  1066.       END
  1067.     ELSE
  1068.       IF f = String THEN
  1069.         IF lhs.a1 = 2 THEN OCC.AllocStringFromChar (lhs) END;
  1070.         len.mode := Con; len.a0 := lhs.a1 - 1; len.typ := OCT.inttyp
  1071.       ELSIF f = DynArr THEN
  1072.         OCI.DescItem (len, lhs.desc, lhs.typ.adr)
  1073.       ELSE
  1074.         len.mode := Con; len.a0 := lhs.typ.n - 1; len.typ := OCT.inttyp
  1075.       END;
  1076.       IF (g = String) & (rhs.a1 = 2) THEN OCC.AllocStringFromChar (rhs) END;
  1077.       OCI.Load (len);                              (*    MOVE.Z  <len>,Dc *)
  1078.       OCI.LoadAdr (lhs); lhs.mode := Pop;          (*    LEA     <lhs>,Aa *)
  1079.       OCI.LoadAdr (rhs); rhs.mode := Pop;          (*    LEA     <rhs>,Ab *)
  1080.       OCC.ForgetReg (lhs.a0); OCC.ForgetReg (rhs.a0);
  1081.       OCC.GetDReg (ch, NIL); OCC.Move (B, lhs, ch);(*    MOVE.B  (Aa)+,Dd *)
  1082.       OCC.PutF5 (OCC.CMP, B, rhs, ch);             (*    CMP.B   (Ab)+,Dd *)
  1083.       L0 := OCC.pc; OCC.PutWord (6600H);           (* 1$ BNE.S   2$       *)
  1084.       OCC.PutF1 (OCC.TST, B, ch);                  (*    TST.B   Dd       *)
  1085.       L1 := OCC.pc; OCC.PutWord (6700H);           (*    BEQ.S   2$       *)
  1086.       OCC.PutWord (OCC.DBF + len.a0);
  1087.       OCC.PutWord (-12);                           (*    DBF.W   Dc,1$    *)
  1088.       IF testNul THEN
  1089.         lhs.mode := RegI; lhs.a1 := 0;
  1090.         OCC.PutF1 (OCC.TST, B, lhs);               (*    TST.B   (Aa)     *)
  1091.       END;                                         (* 2$                  *)
  1092.       OCC.PatchWord (L0, OCC.pc - L0 - 2);
  1093.       OCC.PatchWord (L1, OCC.pc - L1 - 2);
  1094.       OCI.Unload (lhs); OCI.Unload (len); OCI.Unload (ch);
  1095.       setCC (lhs, cc)
  1096.     END
  1097.   END CompStrings;
  1098.  
  1099.   (*------------------------------------*)
  1100.   PROCEDURE CompBool (cc : LONGINT);
  1101.  
  1102.     VAR result : BOOLEAN; swap : OCT.Item;
  1103.  
  1104.   BEGIN (* CompBool *)
  1105.     IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1106.       IF cc = OCC.EQ THEN result := (lhs.a0 = rhs.a0)
  1107.       ELSE result := (lhs.a0 # rhs.a0)
  1108.       END;
  1109.       IF result THEN setCC (lhs, OCC.T)
  1110.       ELSE setCC (lhs, OCC.F)
  1111.       END;
  1112.     ELSE
  1113.       IF lhs.mode = Con THEN (* swap operands *)
  1114.         swap := rhs; rhs := lhs; lhs := swap
  1115.       END;
  1116.       IF rhs.mode = Coc THEN loadB (rhs)
  1117.       ELSIF (rhs.mode = Con) & (rhs.a0 # 0) THEN
  1118.         (* Comparing with TRUE.
  1119.         ** Invert the CC so that a TST can be used.
  1120.         *)
  1121.         cc := OCC.invertedCC (cc); rhs.a0 := 0
  1122.       END;
  1123.       cmp (lhs, rhs, freeRegs); setCC (lhs, cc)
  1124.     END; (* IF *)
  1125.   END CompBool;
  1126.  
  1127. BEGIN (* Op *)
  1128.   IF lhs.typ # rhs.typ THEN
  1129.     f := lhs.typ.form; g := rhs.typ.form;
  1130.     CASE f OF
  1131.       Undef :
  1132.       |
  1133.       SInt :
  1134.         IF g = Int THEN      ConvertInts (lhs, rhs.typ)
  1135.         ELSIF g = LInt THEN  ConvertInts (lhs, rhs.typ)
  1136.         ELSIF g = Real THEN  ConvertReals (lhs, rhs.typ)
  1137.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1138.         ELSE OCS.Mark (100)
  1139.         END
  1140.       |
  1141.       Int :
  1142.         IF g = SInt THEN    ConvertInts (rhs, lhs.typ)
  1143.         ELSIF g = LInt THEN ConvertInts (lhs, rhs.typ)
  1144.         ELSIF g = Real THEN  ConvertReals (lhs, rhs.typ)
  1145.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1146.         ELSE OCS.Mark (100)
  1147.         END
  1148.       |
  1149.       LInt :
  1150.         IF g = SInt THEN   ConvertInts (rhs, lhs.typ)
  1151.         ELSIF g = Int THEN ConvertInts (rhs, lhs.typ)
  1152.         ELSIF g = Real THEN  ConvertReals (lhs, rhs.typ)
  1153.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1154.         ELSE OCS.Mark (100)
  1155.         END
  1156.       |
  1157.       Real :
  1158.         IF g IN intSet THEN  ConvertReals (rhs, lhs.typ)
  1159.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1160.         ELSE OCS.Mark (100)
  1161.         END
  1162.       |
  1163.       LReal :
  1164.         IF g IN intSet THEN ConvertReals (rhs, lhs.typ)
  1165.         ELSIF g = Real THEN ConvertReals (rhs, lhs.typ)
  1166.         ELSE OCS.Mark (100)
  1167.         END
  1168.       |
  1169.       BSet, WSet, Set :
  1170.         IF g IN setSet THEN
  1171.           IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1172.             IF g >= f THEN lhs.typ := rhs.typ
  1173.             ELSE rhs.typ := lhs.typ
  1174.             END
  1175.           ELSIF lhs.mode = Con THEN
  1176.             SetSetType (lhs);
  1177.             IF g >= lhs.typ.form THEN lhs.typ := rhs.typ
  1178.             ELSE OCS.Mark (100)
  1179.             END
  1180.           ELSIF rhs.mode = Con THEN
  1181.             SetSetType (rhs);
  1182.             IF f >= rhs.typ.form THEN rhs.typ := lhs.typ
  1183.             ELSE OCS.Mark (100)
  1184.             END
  1185.           ELSE OCS.Mark (100)
  1186.           END
  1187.         ELSE OCS.Mark (100)
  1188.         END
  1189.       |
  1190.       NilTyp :
  1191.         IF ~(g IN nilSet) THEN OCS.Mark (100) END
  1192.       |
  1193.       Pointer :
  1194.         IF (g = Pointer) & (OCT.Tagged (lhs.typ) = OCT.Tagged (rhs.typ)) THEN
  1195.           p := lhs.typ.BaseTyp; q := rhs.typ.BaseTyp;
  1196.           IF (p.form = Record) & (q.form = Record) THEN
  1197.             IF p.n < q.n THEN r := p; p := q; q := r END;
  1198.             WHILE (p # q) & (p # NIL) DO p := p.BaseTyp END;
  1199.             IF p = NIL THEN OCS.Mark (100) END
  1200.           ELSE
  1201.             OCS.Mark (100)
  1202.           END
  1203.         ELSIF OCT.Address (lhs.typ) THEN
  1204.           IF ~(g IN {AdrTyp, NilTyp}) THEN OCS.Mark (100) END
  1205.         ELSIF g # NilTyp THEN
  1206.           OCS.Mark (100)
  1207.         END
  1208.       |
  1209.       AdrTyp :
  1210.         IF ~OCT.Address (rhs.typ) THEN OCS.Mark (100) END
  1211.       |
  1212.       PtrTyp, BPtrTyp, ProcTyp, TagTyp :
  1213.         IF g # NilTyp THEN OCS.Mark (100) END
  1214.       |
  1215.       Char :
  1216.         IF (g = String) & (rhs.a1 <= 2) THEN
  1217.           rhs.a0 := rhs.a2; rhs.typ := OCT.chartyp; g := Char
  1218.         ELSE OCS.Mark (100)
  1219.         END
  1220.       |
  1221.       String :
  1222.         IF (g = Char) & (lhs.a1 <= 2) THEN
  1223.           lhs.a0 := lhs.a2; lhs.typ := OCT.chartyp; f := Char
  1224.         ELSIF (g = String) & (lhs.a1 <= 2) & (rhs.a1 <= 2) THEN
  1225.           lhs.a0 := lhs.a2; lhs.typ := OCT.chartyp; f := Char;
  1226.           rhs.a0 := rhs.a2; rhs.typ := OCT.chartyp; g := Char
  1227.         END
  1228.       |
  1229.       Byte, Bool, NoTyp, Record, Word, Longword :
  1230.         OCS.Mark (100);
  1231.       |
  1232.       Array, DynArr :
  1233.       |
  1234.     ELSE
  1235.       OCS.Mark (1012); OCS.Mark (f)
  1236.     END; (* CASE f *)
  1237.   END; (* IF *)
  1238.  
  1239.   f := lhs.typ.form; g := rhs.typ.form; size := lhs.typ.size;
  1240.   IF lhs.mode = RList THEN (* lhs is a function procedure result *)
  1241.     IF f # Pointer THEN OCS.Mark (956) END;
  1242.     OCC.FreeReg (lhs); lhs.mode := Reg; lhs.a0 := D0;
  1243.     OCC.ReserveReg (D0, NIL)
  1244.   END;
  1245.   IF rhs.mode = RList THEN (* rhs is a function procedure result *)
  1246.     IF f # Pointer THEN OCS.Mark (956) END;
  1247.     OCC.FreeReg (rhs); rhs.mode := Reg; rhs.a0 := D0;
  1248.     OCC.ReserveReg (D0, NIL)
  1249.   END;
  1250.  
  1251.   CASE op OF
  1252.     times :
  1253.       IF f IN intSet THEN
  1254.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1255.           CheckOverflow (times, lhs, rhs);
  1256.           lhs.a0 := lhs.a0 * rhs.a0; SetIntType (lhs)
  1257.         ELSE
  1258.           MultiplyInts (lhs, rhs, size, freeRegs)
  1259.         END
  1260.       ELSIF f IN realSet THEN
  1261.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1262.           lhs.a0 :=
  1263.             SYS.VAL (LONGINT,
  1264.               SYS.VAL (REAL, lhs.a0) * SYS.VAL (REAL, rhs.a0))
  1265.         ELSE
  1266.           RealMath (times, lhs, rhs)
  1267.         END
  1268.       ELSIF f IN setSet THEN
  1269.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1270.           lhs.a0 :=
  1271.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) * SYS.VAL (SET, rhs.a0))
  1272.         ELSIF lhs.mode = Con THEN
  1273.           OCI.Load (rhs); OCC.PutF6 (OCC.ANDI, size, lhs, rhs); lhs := rhs;
  1274.           rhs.mode := Undef
  1275.         ELSE
  1276.           OCI.Load (lhs); OCC.PutF5 (OCC.AND, size, rhs, lhs)
  1277.         END
  1278.       ELSIF f # Undef THEN OCS.Mark (101)
  1279.       END
  1280.     |
  1281.     slash :
  1282.       IF f IN (realSet + intSet) THEN
  1283.         IF f IN intSet THEN
  1284.           ConvertReals (lhs, OCT.realtyp); ConvertReals (rhs, OCT.realtyp)
  1285.         END;
  1286.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1287.           lhs.a0 :=
  1288.             SYS.VAL (LONGINT,
  1289.               SYS.VAL (REAL, lhs.a0) / SYS.VAL (REAL, rhs.a0))
  1290.         ELSE
  1291.           RealMath (slash, lhs, rhs)
  1292.         END
  1293.       ELSIF f IN setSet THEN
  1294.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1295.           lhs.a0 :=
  1296.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) / SYS.VAL (SET, rhs.a0))
  1297.         ELSIF rhs.mode = Con THEN
  1298.           OCI.Load (lhs); OCC.PutF6 (OCC.EORI, size, rhs, lhs)
  1299.         ELSIF lhs.mode = Con THEN
  1300.           OCI.Load (rhs); OCC.PutF6 (OCC.EORI, size, lhs, rhs);
  1301.           lhs := rhs; rhs.mode := Undef
  1302.         ELSE
  1303.           OCI.Load (lhs); OCI.Load (rhs);
  1304.           OCC.PutF5 (OCC.EOR, size, rhs, lhs)
  1305.         END
  1306.       ELSIF f # Undef THEN OCS.Mark (102)
  1307.       END
  1308.     |
  1309.     div :
  1310.       IF f IN intSet THEN
  1311.         IF (rhs.mode = Con) & (rhs.a0 = 0) THEN
  1312.           OCS.Mark (205); rhs.a0 := 1
  1313.         END;
  1314.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1315.           lhs.a0 := lhs.a0 DIV rhs.a0; SetIntType (lhs);
  1316.         ELSE
  1317.           DivideInts (lhs, rhs, size, freeRegs);
  1318.         END
  1319.       ELSIF f # Undef THEN OCS.Mark (103)
  1320.       END
  1321.     |
  1322.     mod :
  1323.       IF f IN intSet THEN
  1324.         IF (rhs.mode = Con) & (rhs.a0 = 0) THEN
  1325.           OCS.Mark (205); rhs.a0 := 1
  1326.         END;
  1327.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1328.           lhs.a0 := lhs.a0 MOD rhs.a0; lhs.typ := rhs.typ
  1329.         ELSE
  1330.           ModulusInts (lhs, rhs, size, freeRegs)
  1331.         END
  1332.       ELSIF f # Undef THEN OCS.Mark (104)
  1333.       END
  1334.     |
  1335.     and :
  1336.       IF rhs.mode # Coc THEN
  1337.         IF rhs.mode = Con THEN
  1338.           IF rhs.a0 = 1 THEN setCC (rhs, OCC.T) ELSE setCC (rhs, OCC.F) END
  1339.         ELSIF rhs.mode <= Reg THEN test (rhs);
  1340.         ELSE OCS.Mark (94); setCC (rhs, OCC.EQ)
  1341.         END
  1342.       END;
  1343.       IF lhs.mode = Con THEN
  1344.         IF lhs.a0 = 0 THEN
  1345.           OCC.FixLink (rhs.a1); OCC.FixLink (rhs.a2); setCC (rhs, OCC.F)
  1346.         END;
  1347.         setCC (lhs, OCC.EQ)
  1348.       END;
  1349.       IF rhs.a2 # 0 THEN lhs.a2 := OCC.MergedLinks (lhs.a2, rhs.a2)
  1350.       END;
  1351.       lhs.a0 := rhs.a0; lhs.a1 := rhs.a1
  1352.     |
  1353.     plus :
  1354.       IF f IN intSet THEN
  1355.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1356.           CheckOverflow (plus, lhs, rhs); INC (lhs.a0, rhs.a0);
  1357.           SetIntType (lhs)
  1358.         ELSE
  1359.           OCI.Load (lhs); OCC.PutF5 (OCC.ADD, size, rhs, lhs);
  1360.           IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END
  1361.         END
  1362.       ELSIF f IN realSet THEN
  1363.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1364.           lhs.a0 :=
  1365.             SYS.VAL (LONGINT,
  1366.               SYS.VAL (REAL, lhs.a0) + SYS.VAL (REAL, rhs.a0))
  1367.         ELSE
  1368.           RealMath (plus, lhs, rhs)
  1369.         END
  1370.       ELSIF f IN setSet THEN
  1371.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1372.           lhs.a0 :=
  1373.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) + SYS.VAL (SET, rhs.a0))
  1374.         ELSIF lhs.mode = Con THEN
  1375.           OCI.Load (rhs); OCC.PutF6 (OCC.ORI, size, lhs, rhs); lhs := rhs;
  1376.           rhs.mode := Undef
  1377.         ELSE
  1378.           OCI.Load (lhs); OCC.PutF5 (OCC.iOR, size, rhs, lhs)
  1379.         END
  1380.       ELSIF f # Undef THEN OCS.Mark (105)
  1381.       END
  1382.     |
  1383.     minus :
  1384.       IF f IN intSet THEN
  1385.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1386.           CheckOverflow (minus, lhs, rhs); DEC (lhs.a0, rhs.a0);
  1387.           SetIntType (lhs)
  1388.         ELSE
  1389.           OCI.Load (lhs); OCC.PutF5 (OCC.SUB, size, rhs, lhs);
  1390.           IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END
  1391.         END
  1392.       ELSIF f IN realSet THEN
  1393.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1394.           lhs.a0 :=
  1395.             SYS.VAL (LONGINT,
  1396.               SYS.VAL (REAL, lhs.a0) - SYS.VAL (REAL, rhs.a0))
  1397.         ELSE
  1398.           RealMath (minus, lhs, rhs)
  1399.         END
  1400.       ELSIF f IN setSet THEN
  1401.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1402.           lhs.a0 :=
  1403.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) - SYS.VAL (SET, rhs.a0));
  1404.         ELSIF rhs.mode = Con THEN
  1405.           rhs.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, rhs.a0));
  1406.           OCI.Load (lhs); OCC.PutF6 (OCC.ANDI, size, rhs, lhs)
  1407.         ELSIF lhs.mode = Con THEN
  1408.           OCI.Load (rhs); OCC.PutF1 (OCC.NOT, size, rhs);
  1409.           IF ~(lhs.a0 = -1) THEN OCC.PutF6 (OCC.ANDI, size, lhs, rhs) END;
  1410.           lhs := rhs; rhs.mode := Undef
  1411.         ELSE
  1412.           OCI.Load (lhs); OCI.Load (rhs); OCC.PutF1 (OCC.NOT, size, rhs);
  1413.           OCC.PutF5 (OCC.AND, size, rhs, lhs)
  1414.         END
  1415.       ELSIF f # Undef THEN OCS.Mark (106)
  1416.       END
  1417.     |
  1418.     or :
  1419.       IF rhs.mode # Coc THEN
  1420.         IF rhs.mode = Con THEN
  1421.           IF rhs.a0 = 1 THEN setCC (rhs, OCC.T) ELSE setCC (rhs, OCC.F) END
  1422.         ELSIF rhs.mode <= Reg THEN test (rhs)
  1423.         ELSE OCS.Mark (95); setCC (rhs, OCC.EQ)
  1424.         END
  1425.       END;
  1426.       IF lhs.mode = Con THEN
  1427.         IF lhs.a0 = 1 THEN
  1428.           OCC.FixLink (rhs.a1); OCC.FixLink (rhs.a2); setCC (rhs, OCC.T)
  1429.         END;
  1430.         setCC (lhs, OCC.EQ)
  1431.       END;
  1432.       IF rhs.a1 # 0 THEN lhs.a1 := OCC.MergedLinks (lhs.a1, rhs.a1) END;
  1433.       lhs.a0 := rhs.a0; lhs.a2 := rhs.a2
  1434.     |
  1435.     eql :
  1436.       IF f IN eqSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.EQ)
  1437.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.EQ)
  1438.       ELSIF f = Bool THEN CompBool (OCC.EQ)
  1439.       ELSIF strings () THEN CompStrings (OCC.EQ, TRUE)
  1440.       ELSE OCS.Mark (107)
  1441.       END
  1442.     |
  1443.     neq :
  1444.       IF f IN eqSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.NE)
  1445.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.NE)
  1446.       ELSIF f = Bool THEN CompBool (OCC.NE)
  1447.       ELSIF strings () THEN CompStrings (OCC.NE, TRUE)
  1448.       ELSE OCS.Mark (107)
  1449.       END
  1450.     |
  1451.     lss :
  1452.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.LT)
  1453.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.CS)
  1454.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.LT)
  1455.       ELSIF strings () THEN CompStrings (OCC.CS, FALSE)
  1456.       ELSE OCS.Mark (108)
  1457.       END
  1458.     |
  1459.     leq :
  1460.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.LE)
  1461.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.LS)
  1462.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.LE)
  1463.       ELSIF strings () THEN CompStrings (OCC.LS, TRUE)
  1464.       ELSE OCS.Mark (108)
  1465.       END
  1466.     |
  1467.     gtr :
  1468.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.GT)
  1469.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.HI)
  1470.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.GT)
  1471.       ELSIF strings () THEN CompStrings (OCC.HI, TRUE)
  1472.       ELSE OCS.Mark (108)
  1473.       END
  1474.     |
  1475.     geq :
  1476.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.GE)
  1477.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.CC)
  1478.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.GE)
  1479.       ELSIF strings () THEN CompStrings (OCC.CC, FALSE)
  1480.       ELSE OCS.Mark (108)
  1481.       END
  1482.     |
  1483.   ELSE
  1484.     OCS.Mark (1013); OCS.Mark (op)
  1485.   END; (* CASE op *)
  1486.  
  1487.   IF freeRegs THEN OCI.Unload (rhs) END;
  1488. END Op;
  1489.  
  1490. END OCE.
  1491.  
  1492. (***************************************************************************
  1493.  
  1494.   $Log: OCE.mod $
  1495.   Revision 5.22  1995/07/02  16:52:04  fjc
  1496.   *** empty log message ***
  1497.  
  1498.   Revision 5.21  1995/07/02  16:50:44  fjc
  1499.   - Fixed pointer to open array bug in DeRef().
  1500.  
  1501.   Revision 5.20  1995/06/29  19:10:45  fjc
  1502.   - Removed code that was second-guessing the garbage collector
  1503.  
  1504.   Revision 5.19  1995/06/15  18:13:29  fjc
  1505.   - Didn't free all registers when processing type tests.
  1506.  
  1507.   Revision 5.18  1995/06/02  18:40:02  fjc
  1508.   - Now uses OCI.CMP.
  1509.  
  1510.   Revision 5.17  1995/05/13  23:07:13  fjc
  1511.   - Changed INTEGER to LONGINT where necessary.
  1512.   - Now allows floating point constant expressions.
  1513.  
  1514.   Revision 5.16  1995/04/23  17:45:49  fjc
  1515.   - Merging 5.26 & 5.27
  1516.  
  1517.   Revision 5.13  1995/03/23  18:18:18  fjc
  1518.   - More work on remembering registers in Index(), Field() and
  1519.     DeRef().
  1520.  
  1521.   Revision 5.12  1995/03/13  11:31:47  fjc
  1522.   - Reverted to forced loading of Ind objects in Field() and
  1523.     Index().
  1524.  
  1525.   Revision 5.11  1995/03/09  19:09:45  fjc
  1526.   - Incorporated changes from 5.22.
  1527.  
  1528.   Revision 5.10  1995/02/27  17:02:54  fjc
  1529.   - Removed tracing code.
  1530.   - Modified to use new register handling procedures.
  1531.  
  1532.   Revision 5.9.1.1  1995/03/08  19:01:25  fjc
  1533.   - OC 5.22
  1534.  
  1535.   Revision 5.9  1995/02/21  11:56:58  fjc
  1536.   - OC 5.21
  1537.  
  1538.   Revision 5.8  1995/01/26  00:17:17  fjc
  1539.   - Release 1.5
  1540.  
  1541.   Revision 5.7  1995/01/03  21:19:32  fjc
  1542.   - Changed OCG to OCM.
  1543.  
  1544.   Revision 5.6  1994/12/16  17:29:27  fjc
  1545.   - Changed Symbol to Label.
  1546.   - Minor modifications to type tests.
  1547.  
  1548.   Revision 5.5  1994/10/23  16:10:52  fjc
  1549.   - All calls to the RTS now made through OCC.CallKernel().
  1550.  
  1551.   Revision 5.4  1994/09/25  17:49:43  fjc
  1552.   - Changed to reflect new object modes and system flags.
  1553.  
  1554.   Revision 5.3  1994/09/15  10:33:02  fjc
  1555.   - Replaced switches with pragmas.
  1556.   - Fixed register reservation bug in DeRef when NIL checking.
  1557.     was on.
  1558.  
  1559.   Revision 5.2  1994/09/08  10:49:29  fjc
  1560.   - Changed to use pragmas/options.
  1561.  
  1562.   Revision 5.1  1994/09/03  19:29:08  fjc
  1563.   - Bumped version number
  1564.  
  1565. ***************************************************************************)
  1566.